home *** CD-ROM | disk | FTP | other *** search
/ Software Vault: The Gold Collection / Software Vault - The Gold Collection (American Databankers) (1993).ISO / cdr48 / qwrit11.zip / QWRITER.PAS < prev   
Pascal/Delphi Source File  |  1993-04-16  |  19KB  |  525 lines
  1.  
  2.  {$A+,B-,D-,E-,F-,I+,N-,O-,R+,S-,V+}
  3.  
  4. (****************************************************************************)
  5. (* QWRITER.PAS - Quick screen writing unit.                                 *)
  6. (* version 1.1 (March 10, 1992)                                             *)
  7. (* TP required: 6.0                                                         *)
  8. (* by Guy McLoughlin                                                        *)
  9. (* Released to the public domain.                                           *)
  10. (****************************************************************************)
  11.  
  12. unit Qwriter;      (* Unit to write Strings directly to the Video-buffer.   *)
  13.  
  14. (****************************************************************************)
  15.  interface
  16. (****************************************************************************)
  17.  
  18. const              (* Set these constants according to the text-screen size *)
  19.                    (* you are using.                                        *)
  20.   Rows      = 25;         
  21.   Columns   = 80;         
  22.   ClearSize = (Rows shl 8) + Columns;
  23.  
  24.                    (* ReadKeyWord constants.                                *)
  25.  
  26.   AnyKey        = 0;
  27.  
  28.   BackSpaceKey  =  3592;
  29.   TabKey        =  3849;
  30.   EnterKey      =  7181;
  31.   EscapeKey     =   283;
  32.   SpaceBarKey   = 14624;
  33.  
  34.   F1Key         = 15104;
  35.   F2Key         = 15360;
  36.   F3Key         = 15616;
  37.   F4Key         = 15872;
  38.   F5Key         = 16128;
  39.   F6Key         = 16384;
  40.   F7Key         = 16640;
  41.   F8Key         = 16896;
  42.   F9Key         = 17152;
  43.   F10Key        = 17408;
  44.  
  45.   HomeKey       = 18176;
  46.   EndKey        = 20224;
  47.   PageUpKey     = 18688;
  48.   PageDownKey   = 20736;
  49.  
  50.   UpArrowKey    = 18432;
  51.   DownArrowKey  = 20480;
  52.   RightArrowKey = 19712;
  53.   LeftArrowKey  = 19200;
  54.  
  55.   InsertKey     = 20992;
  56.   DeleteKey     = 21248;
  57.  
  58.  
  59.                    (* Boolean constants.                                    *)
  60.   On  = true;
  61.   Off = false;
  62.  
  63.  
  64. type               (* Maximum length of display string.                     *)
  65.   VidString = string[Columns];  
  66.  
  67.  
  68. var                (* Boolean use to check Video-Mode.                      *)
  69.   ColorMode : boolean;       
  70.  
  71.   NormAttr,        (* Normal text-attribute variable.                       *)
  72.   RevAttr : word;  (* Reversed text-attribute variable.                     *)
  73.  
  74.  
  75. (****************************************************************************)
  76. (*  Unit Routines                                                           *)
  77. (****************************************************************************)
  78.  
  79.                    (* Read a key-press.                                     *)
  80.   function ReadKeyChar : char;
  81.  
  82.                    (* Read key and scan-code at once.                       *)
  83.   function ReadKeyWord : word;
  84.  
  85.  
  86.                    (* Clear the keyboard-buffer.                            *)
  87.   procedure ClearKeyBuff;
  88.  
  89.  
  90.                    (* Wait for specific key to be pressed.                  *)
  91.   procedure Pause(Key : word);
  92.  
  93.  
  94.                    (* Standard PC beep.                                     *)
  95.   procedure Beep;
  96.  
  97.  
  98.                    (* Convert an integer-type to a string-type.             *)
  99.   function Int2Str(Number : longint; Width : byte) : VidString;
  100.  
  101.  
  102.                    (* Convert a real-type to a string-type.                 *)
  103.   function Real2Str(Number : real;
  104.                     Width, Decimals : byte) : VidString;
  105.  
  106.  
  107.                    (* Hide or show cursor.                                  *)
  108.   procedure HideCursor(Switch : boolean);
  109.  
  110.  
  111.                    (* Clear screen using a specific color attribute.        *)
  112.   procedure ClearScr(Attr : byte);
  113.  
  114.  
  115.                    (* Turn the "blink-bit" off to allow 16 different        *)
  116.                    (* background colors. WORKS FOR EGA+ VIDEO MODES ONLY!   *)
  117.   procedure BlinkBit(Switch : boolean);
  118.  
  119.  
  120.                    (* Procedure to write directly to the video-buffer at    *)
  121.                    (* Xaxis, Yaxis, using Cattr color-attribute.            *)
  122.   procedure Qwrite(InString : VidString;
  123.                    Xaxis, Yaxis : byte;
  124.                    Cattr : word);
  125.  
  126.  
  127.                    (* Procedure to vertically write directly to the video-  *)
  128.                    (* buffer at Xaxis, Yaxis, using Cattr color-attribute.  *)
  129.   procedure VQwrite(InString : VidString;
  130.                     Xaxis, Yaxis : byte;
  131.                     Cattr : word);
  132.  
  133.  
  134.                    (* Procedure to change video-buffer color attributes,    *)
  135.                    (* at Xaxis, Yaxis, using Cattr color-attribute.         *)
  136.   procedure ChangeAttr(AttrsToChange, Xaxis, Yaxis, Cattr : byte);
  137.  
  138.  
  139.                    (* Procedure to vertically change video-buffer color     *)
  140.                    (* attributes, at Xaxis, Yaxis, using Cattr color-       *)
  141.                    (* attribute.                                            *)
  142.   procedure VChangeAttr(AttrsToChange, Xaxis, Yaxis, Cattr : byte);
  143.  
  144.  
  145.                    (* Function to create a hi-light bar "pick-list" menu.   *)
  146.   function PickIt(TopY,                          (* Top Y axis position.    *)
  147.                   BotY,                          (* Bottom Y axis position. *)
  148.                   Xaxis,                         (* X axis position.        *)
  149.                   HiLightBarSize : byte;         (* Length of hi-light bar. *)
  150.                   NormalAttr,                    (* Normal attribute.       *)
  151.                   HiLightBarAttr : word) : word; (* Hi-light bar attribute. *)
  152.  
  153.  
  154. (****************************************************************************)
  155.  implementation
  156. (****************************************************************************)
  157.  
  158. var
  159.   VidAddr : word;  (* Video-buffer address variable.                        *)
  160.  
  161.                    (* Set the Video-buffer address.                         *)
  162.   procedure SetVideoAddress; 
  163.   begin
  164.     if ((Mem[$0000:$0410] and $30) <> $30) then
  165.       begin
  166.         VidAddr := $B800;   (* Color video mode.                            *)
  167.         ColorMode := true;
  168.         NormAttr := $17;    (* Lightgray text on a blue background.         *)
  169.         RevAttr := $71      (* Blue text on a lightgray background.         *)
  170.       end
  171.     else
  172.       begin
  173.         VidAddr := $B000;   (* Monochrome video mode.                       *)
  174.         ColorMode := false;
  175.         NormAttr := $07;    (* Lightgray text on a black background.        *)
  176.         RevAttr := $70      (* Black text on a lightgray background.        *)
  177.       end
  178.   end;
  179.  
  180.  
  181.                    (* Read a key-press.                                     *)
  182.   function ReadKeyChar : char; assembler;
  183.   asm
  184.     mov ah, 0
  185.     int 16h
  186.   end;
  187.  
  188.  
  189.                    (* Read standard and extended key codes at once.         *)
  190.   function ReadKeyWord : word; assembler;
  191.   asm
  192.     mov ah, 0
  193.     int 16h
  194.   end;
  195.  
  196.  
  197.                    (* Clear the keyboard-buffer.                            *)
  198.   procedure ClearKeyBuff; assembler;
  199.   asm
  200.     @1: mov ah, 1
  201.         int 16h
  202.         jz  @2
  203.         mov ah, 0
  204.         int 16h
  205.         jmp @1
  206.     @2:
  207.   end;
  208.  
  209.  
  210.                    (* Function to indicate if a key is in the keyboard      *)
  211.                    (* buffer.                                               *)
  212.   function KeyPressed : boolean; assembler;
  213.   asm
  214.     mov ah, 1
  215.     int 16h
  216.     mov ax, 0
  217.     jz @1
  218.     inc ax
  219.     @1:
  220.   end;
  221.  
  222.  
  223.                    (* Wait for specific key to be pressed.                  *)
  224.   procedure Pause(Key : word);
  225.   begin
  226.     ClearKeyBuff;
  227.     if (Key = AnyKey) then
  228.       repeat until(Keypressed)
  229.     else
  230.       repeat until(ReadKeyWord = Key)
  231.   end;
  232.  
  233.  
  234.                    (* Standard PC beep.                                     *)
  235.   procedure Beep;
  236.   begin
  237.     write(#7)
  238.   end;
  239.  
  240.  
  241.                    (* Convert an integer-type to a string-type.             *)
  242.   function Int2Str(Number : longint; Width : byte) : VidString;
  243.   var
  244.     TempString : VidString;
  245.   begin
  246.     Str(Number:Width, TempString);
  247.     Int2Str := TempString
  248.   end;
  249.  
  250.  
  251.                    (* Convert a real-type to a string-type.                 *)
  252.   function Real2Str(Number : real;
  253.                     Width, Decimals : byte) : VidString;
  254.   var
  255.     TempString : VidString;
  256.   begin
  257.     Str(Number:Width:Decimals, TempString);
  258.     Real2Str := TempString
  259.   end;
  260.  
  261.  
  262.                    (* Hide or show cursor.                                  *)
  263.   procedure HideCursor(Switch : boolean);
  264.   begin
  265.     if (Switch = true) then
  266.       asm mov CX, 2000h end
  267.     else
  268.       if ColorMode then
  269.         asm mov CX, 0607h end
  270.       else
  271.         asm mov CX, 0C0Dh end;
  272.     asm
  273.       mov AX, 0100h
  274.       int 10h
  275.     end
  276.   end;
  277.  
  278.  
  279.                    (* Clear screen using a specific color.                  *)
  280.   procedure ClearScr(Attr : byte); assembler;
  281.   asm
  282.     mov bh, Attr
  283.     xor cx, cx
  284.     mov dx, ClearSize
  285.     mov ah, 7
  286.     mov al, 25
  287.     int 10h
  288.     mov ah, 2
  289.     mov bh, 0
  290.     xor dx, dx
  291.     int 10h
  292.   end;
  293.  
  294.  
  295.                    (* Turn the "blink-bit" off to allow 16 different        *)
  296.                    (* background colors. WORKS FOR EGA+ VIDEO MODES ONLY!   *)
  297.   procedure BlinkBit(Switch : boolean); assembler;
  298.   asm
  299.     mov AX, 1003h
  300.     mov Bl, Switch
  301.     int 10h
  302.   end;
  303.  
  304.  
  305.                    (* Procedure to write directly to the video-buffer at    *)
  306.                    (* Xaxis, Yaxis, using Cattr color-attribute.            *)
  307.   procedure Qwrite(InString : VidString;
  308.                    Xaxis, Yaxis : byte;
  309.                    Cattr : word);
  310.   var
  311.     IsIndex   : byte;        (* InString position index.                    *)
  312.     VidOffset : word;        (* Video-address offset position.              *)
  313.   begin
  314.                    (* If InString is empty then exit procedure.             *)
  315.     if InString = '' then
  316.       exit;
  317.                    (* Stop any illeagal Xaxis, Yaxis positions.             *)
  318.     if Columns < (Xaxis + length(InString)) then
  319.       Xaxis := Columns - length(InString);
  320.     if Rows < Yaxis then
  321.       Yaxis := Rows;
  322.  
  323.                    (* Calculate the offset into the video-buffer array.     *)
  324.     VidOffset := ((((Yaxis - 1) * Columns) + (Xaxis - 1)) * 2);
  325.  
  326.                    (* Make sure string is not too long!                     *)
  327.     if ((length(InString) + Xaxis) > Columns) then
  328.       InString[0] := chr((Columns + 1) - Xaxis);
  329.  
  330.                    (* Write string to video-buffer.                         *)
  331.     for IsIndex := 0 to (length(InString) - 1) do
  332.       MemW[VidAddr : (VidOffset + (IsIndex * 2))] :=
  333.           (Cattr shl 8) + byte(InString[IsIndex + 1]);
  334.   end;
  335.  
  336.                    (* Procedure to vertically write directly to the video-  *)
  337.                    (* buffer at Xaxis, Yaxis, using Cattr color-attribute.  *)
  338.   procedure VQwrite(InString : VidString;
  339.                     Xaxis, Yaxis : byte;
  340.                     Cattr : word);
  341.   var
  342.     IsIndex   : byte; (* InString position index.                           *)
  343.     VidOffset : word; (* Video-address offset position.                     *)
  344.   begin
  345.                    (* If InString is empty then exit procedure.             *)
  346.     if InString = '' then
  347.       exit;
  348.                    (* Stop any illeagal Xaxis, Yaxis positions.             *)
  349.     if Columns < Xaxis then
  350.       Xaxis := Columns;
  351.     if Rows < Yaxis then
  352.       Yaxis := Rows;
  353.  
  354.                    (* Calculate the offset into the video-buffer array.     *)
  355.     VidOffset := ((((Yaxis - 1) * Columns) + (Xaxis - 1)) * 2);
  356.  
  357.                    (* Make sure string is not too long!                     *)
  358.     if ((length(InString) + Yaxis) > Rows) then
  359.       InString[0] := chr((Rows + 1) - Yaxis);
  360.  
  361.                    (* Write string to screen.                               *)
  362.     for IsIndex := 0 to (length(InString) - 1) do
  363.       MemW[VidAddr : (VidOffset + (IsIndex * Columns * 2))] :=
  364.           (Cattr shl 8) + byte(InString[IsIndex + 1]);
  365.   end;
  366.  
  367.  
  368.                    (* Procedure to change video-buffer color attributes,    *)
  369.                    (* at Xaxis, Yaxis, using Cattr color-attribute.         *)
  370.   procedure ChangeAttr(AttrsToChange, Xaxis, Yaxis, Cattr : byte);
  371.   var
  372.     AttrIndex,
  373.     AttrOffset  : word;
  374.   begin
  375.                    (* Stop any illeagal Xaxis, Yaxis positions.             *)
  376.     if (Yaxis > Rows) then
  377.       Yaxis := Rows;
  378.     if (Xaxis > Columns) then
  379.       Xaxis := Columns;
  380.  
  381.                    (* Calculate the offset into the video-buffer array.     *)
  382.     AttrOffset := ((((Yaxis - 1) * Columns) + (Xaxis - 1)) * 2) + 1;
  383.  
  384.                    (* Make sure the number of attributes to change is not   *)
  385.                    (* too many.                                             *)
  386.     if (AttrsToChange > (Columns - Xaxis)) then
  387.       AttrsToChange := (Columns - Xaxis) + 1;
  388.  
  389.                    (* Change color attributes in the video-buffer array.    *)
  390.     for AttrIndex := 0 to (AttrsToChange - 1) do
  391.       Mem[VidAddr : (AttrOffset + (AttrIndex * 2))] := Cattr
  392.   end;
  393.  
  394.  
  395.                    (* Procedure to vertically change video-buffer color     *)
  396.                    (* attributes, at Xaxis, Yaxis, using Cattr color-       *)
  397.                    (* attribute.                                            *)
  398.   procedure VChangeAttr(AttrsToChange, Xaxis, Yaxis, Cattr : byte);
  399.   var
  400.     AttrIndex,
  401.     AttrOffset  : word;
  402.   begin
  403.                    (* Stop any illeagal Xaxis, Yaxis positions.             *)
  404.     if (Yaxis > Rows) then
  405.       Yaxis := Rows;
  406.     if (Xaxis > Columns) then
  407.       Xaxis := Columns;
  408.  
  409.                    (* Calculate the offset into the video-buffer array.     *)
  410.     AttrOffset := ((((Yaxis - 1) * Columns) + (Xaxis - 1)) * 2) + 1;
  411.  
  412.                    (* Make sure the number of attributes to change is not   *)
  413.                    (* too many.                                             *)
  414.     if (AttrsToChange > (Rows - Yaxis)) then
  415.       AttrsToChange := (Rows - Yaxis) + 1;
  416.  
  417.                    (* Change color attributes in the video-buffer array.    *)
  418.     for AttrIndex := 0 to (AttrsToChange - 1) do
  419.       Mem[VidAddr : (AttrOffset + (AttrIndex * Columns * 2))] := Cattr
  420.   end;
  421.  
  422.  
  423.                    (* Function to create a hi-light bar "pick-list" menu.   *)
  424.   function PickIt(TopY,                          (* Top Y axis position.    *)
  425.                   BotY,                          (* Bottom Y axis position. *)
  426.                   Xaxis,                         (* X axis position.        *)
  427.                   HiLightBarSize : byte;         (* Length of hi-light bar. *)
  428.                   NormalAttr,                    (* Normal attribute.       *)
  429.                   HiLightBarAttr : word) : word; (* Hi-light bar attribute. *)
  430.   var
  431.     Quit,
  432.     EscapeQuit,
  433.     MoveHiLightBar : boolean;
  434.     BarOffset      : byte;
  435.     DUD            : char;
  436.   begin
  437.                    (* Initialize PickIt variables.                          *)
  438.     Quit := false;
  439.     EscapeQuit := false;
  440.     BarOffset := 0;
  441.     MoveHiLightBar := true;
  442.  
  443.                    (* Repeat..Until it's time to quit.                      *)
  444.     repeat
  445.  
  446.                    (* Clear key-buffer.                                     *)
  447.       ClearKeyBuff;
  448.  
  449.                    (* Display / re-display the hi-light bar.                *)
  450.       if MoveHiLightBar then
  451.         ChangeAttr(HiLightBarSize, Xaxis, (TopY + BarOffset), HiLightBarAttr);
  452.  
  453.                    (* Get User key choice.                                  *)
  454.       case ReadKeyWord of
  455.  
  456.         UpArrowKey,
  457.         LeftArrowKey  : begin
  458.                    (* Hide hi-light bar.                                    *)
  459.                           ChangeAttr(HiLightBarSize,
  460.                                      Xaxis, (TopY + BarOffset), NormalAttr);
  461.  
  462.                    (* Set "MoveHiLightBar" boolean.                         *)
  463.                           MoveHiLightBar := true;
  464.  
  465.                    (* If hi-light bar is NOT in the starting position, then *)
  466.                    (* decrement it's position by one.                       *)
  467.                           if (BarOffset > 0) then
  468.                             dec(BarOffset, 1)
  469.  
  470.                    (* Else, if hi-light bar IS in the starting position,    *)
  471.                    (* then move it to the LAST position.                    *)
  472.                           else
  473.                             BarOffset := (BotY - TopY)
  474.                         end;
  475.  
  476.         DownArrowKey,
  477.         RightArrowKey : begin
  478.                    (* Hide hi-light bar.                                    *)
  479.                           ChangeAttr(HiLightBarSize,
  480.                                      Xaxis, (TopY + BarOffset), NormalAttr);
  481.  
  482.                    (* Set "MoveHiLightBar" boolean.                         *)
  483.                           MoveHiLightBar := true;
  484.  
  485.                    (* If hi-light bar is NOT in the LAST position, then     *)
  486.                    (* increment it's position by one.                       *)
  487.                           if (BarOffset < (BotY - TopY)) then
  488.                             inc(BarOffset, 1)
  489.  
  490.                    (* Else, if hi-light bar IS in the LAST position, then   *)
  491.                    (* move it to the starting position.                     *)
  492.                           else
  493.                             BarOffset := 0
  494.                         end;
  495.  
  496.                    (* <ENTER> key pressed, quit-pick loop.                  *)
  497.         EnterKey   : Quit := true;
  498.  
  499.                    (* <ESC> key pressed, quit pick-loop.                    *)
  500.         EscapeKey  : EscapeQuit := true
  501.  
  502.                    (* Else, discard User's key choice.                      *)
  503.         else
  504.           MoveHiLightBar := false
  505.       end
  506.  
  507.                    (* Repeat..Until it's time to quit.                      *)
  508.     until (Quit or EscapeQuit);
  509.  
  510.                    (* If the User pressed the <ESC> key, then return 0.     *)
  511.     if EscapeQuit then
  512.       PickIt := 0
  513.  
  514.                    (* Else, return the hi-light bar position.               *)
  515.     else
  516.       PickIt := BarOffset + 1
  517.   end;
  518.  
  519.  
  520. BEGIN
  521.   SetVideoAddress
  522. END.
  523.  
  524.  
  525.